home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLLIST.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-01-01  |  18.6 KB  |  867 lines
  1. /* xllist - xlisp built-in list functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack;
  7. extern NODE *s_unbound;
  8. extern NODE *true;
  9.  
  10. /* external routines */
  11. extern int eq(),eql(),equal();
  12.  
  13. /* forward declarations */
  14. FORWARD NODE *cxr();
  15. FORWARD NODE *nth(),*assoc();
  16. FORWARD NODE *subst(),*sublis(),*map();
  17. FORWARD NODE *cequal();
  18.  
  19. /* xcar - return the car of a list */
  20. NODE *xcar(args)
  21.   NODE *args;
  22. {
  23.     return (cxr(args,"a"));
  24. }
  25.  
  26. /* xcdr - return the cdr of a list */
  27. NODE *xcdr(args)
  28.   NODE *args;
  29. {
  30.     return (cxr(args,"d"));
  31. }
  32.  
  33. /* xcaar - return the caar of a list */
  34. NODE *xcaar(args)
  35.   NODE *args;
  36. {
  37.     return (cxr(args,"aa"));
  38. }
  39.  
  40. /* xcadr - return the cadr of a list */
  41. NODE *xcadr(args)
  42.   NODE *args;
  43. {
  44.     return (cxr(args,"da"));
  45. }
  46.  
  47. /* xcdar - return the cdar of a list */
  48. NODE *xcdar(args)
  49.   NODE *args;
  50. {
  51.     return (cxr(args,"ad"));
  52. }
  53.  
  54. /* xcddr - return the cddr of a list */
  55. NODE *xcddr(args)
  56.   NODE *args;
  57. {
  58.     return (cxr(args,"dd"));
  59. }
  60.  
  61. /* cxr - common car/cdr routine */
  62. LOCAL NODE *cxr(args,adstr)
  63.   NODE *args; char *adstr;
  64. {
  65.     NODE *list;
  66.  
  67.     /* get the list */
  68.     list = xlmatch(LIST,&args);
  69.     xllastarg(args);
  70.  
  71.     /* perform the car/cdr operations */
  72.     while (*adstr && consp(list))
  73.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  74.  
  75.     /* make sure the operation succeeded */
  76.     if (*adstr && list)
  77.     xlfail("bad argument");
  78.  
  79.     /* return the result */
  80.     return (list);
  81. }
  82.  
  83. /* xcons - construct a new list cell */
  84. NODE *xcons(args)
  85.   NODE *args;
  86. {
  87.     NODE *arg1,*arg2,*val;
  88.  
  89.     /* get the two arguments */
  90.     arg1 = xlarg(&args);
  91.     arg2 = xlarg(&args);
  92.     xllastarg(args);
  93.  
  94.     /* construct a new list element */
  95.     val = newnode(LIST);
  96.     rplaca(val,arg1);
  97.     rplacd(val,arg2);
  98.  
  99.     /* return the list */
  100.     return (val);
  101. }
  102.  
  103. /* xlist - built a list of the arguments */
  104. NODE *xlist(args)
  105.   NODE *args;
  106. {
  107.     NODE *oldstk,arg,list,val,*last,*lptr;
  108.  
  109.     /* create a new stack frame */
  110.     oldstk = xlsave(&arg,&list,&val,NULL);
  111.  
  112.     /* initialize */
  113.     arg.n_ptr = args;
  114.  
  115.     /* evaluate and append each argument */
  116.     for (last = NULL; arg.n_ptr != NULL; last = lptr) {
  117.  
  118.     /* evaluate the next argument */
  119.     val.n_ptr = xlarg(&arg.n_ptr);
  120.  
  121.     /* append this argument to the end of the list */
  122.     lptr = newnode(LIST);
  123.     if (last == NULL)
  124.         list.n_ptr = lptr;
  125.     else
  126.         rplacd(last,lptr);
  127.     rplaca(lptr,val.n_ptr);
  128.     }
  129.  
  130.     /* restore the previous stack frame */
  131.     xlstack = oldstk;
  132.  
  133.     /* return the list */
  134.     return (list.n_ptr);
  135. }
  136.  
  137. /* xappend - built-in function append */
  138. NODE *xappend(args)
  139.   NODE *args;
  140. {
  141.     NODE *oldstk,arg,list,last,val,*lptr;
  142.  
  143.     /* create a new stack frame */
  144.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  145.  
  146.     /* initialize */
  147.     arg.n_ptr = args;
  148.  
  149.     /* evaluate and append each argument */
  150.     while (arg.n_ptr) {
  151.  
  152.     /* evaluate the next argument */
  153.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  154.  
  155.     /* append each element of this list to the result list */
  156.     while (consp(list.n_ptr)) {
  157.  
  158.         /* append this element */
  159.         lptr = newnode(LIST);
  160.         if (last.n_ptr == NULL)
  161.         val.n_ptr = lptr;
  162.         else
  163.         rplacd(last.n_ptr,lptr);
  164.         rplaca(lptr,car(list.n_ptr));
  165.  
  166.         /* save the new last element */
  167.         last.n_ptr = lptr;
  168.  
  169.         /* move to the next element */
  170.         list.n_ptr = cdr(list.n_ptr);
  171.     }
  172.  
  173.     /* make sure the list ended in a nil */
  174.     if (list.n_ptr != NULL)
  175.         xlfail("bad list");
  176.     }
  177.  
  178.     /* restore previous stack frame */
  179.     xlstack = oldstk;
  180.  
  181.     /* return the list */
  182.     return (val.n_ptr);
  183. }
  184.  
  185. /* xreverse - built-in function reverse */
  186. NODE *xreverse(args)
  187.   NODE *args;
  188. {
  189.     NODE *oldstk,list,val,*lptr;
  190.  
  191.     /* create a new stack frame */
  192.     oldstk = xlsave(&list,&val,NULL);
  193.  
  194.     /* get the list to reverse */
  195.     list.n_ptr = xlmatch(LIST,&args);
  196.     xllastarg(args);
  197.  
  198.     /* append each element of this list to the result list */
  199.     while (consp(list.n_ptr)) {
  200.  
  201.     /* append this element */
  202.     lptr = newnode(LIST);
  203.     rplaca(lptr,car(list.n_ptr));
  204.     rplacd(lptr,val.n_ptr);
  205.     val.n_ptr = lptr;
  206.  
  207.     /* move to the next element */
  208.     list.n_ptr = cdr(list.n_ptr);
  209.     }
  210.  
  211.     /* make sure the list ended in a nil */
  212.     if (list.n_ptr != NULL)
  213.     xlfail("bad list");
  214.  
  215.     /* restore previous stack frame */
  216.     xlstack = oldstk;
  217.  
  218.     /* return the list */
  219.     return (val.n_ptr);
  220. }
  221.  
  222. /* xlast - return the last cons of a list */
  223. NODE *xlast(args)
  224.   NODE *args;
  225. {
  226.     NODE *list;
  227.  
  228.     /* get the list */
  229.     list = xlmatch(LIST,&args);
  230.     xllastarg(args);
  231.  
  232.     /* find the last cons */
  233.     while (consp(list) && cdr(list))
  234.     list = cdr(list);
  235.  
  236.     /* return the last element */
  237.     return (list);
  238. }
  239.  
  240. /* xmember - built-in function 'member' */
  241. NODE *xmember(args)
  242.   NODE *args;
  243. {
  244.     NODE *oldstk,x,list,fcn,*val;
  245.     int tresult;
  246.  
  247.     /* create a new stack frame */
  248.     oldstk = xlsave(&x,&list,&fcn,NULL);
  249.  
  250.     /* get the expression to look for and the list */
  251.     x.n_ptr = xlarg(&args);
  252.     list.n_ptr = xlmatch(LIST,&args);
  253.     xltest(&fcn.n_ptr,&tresult,&args);
  254.     xllastarg(args);
  255.  
  256.     /* look for the expression */
  257.     for (val = NULL; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr))
  258.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult) {
  259.         val = list.n_ptr;
  260.         break;
  261.     }
  262.  
  263.     /* restore the previous stack frame */
  264.     xlstack = oldstk;
  265.  
  266.     /* return the result */
  267.     return (val);
  268. }
  269.  
  270. /* xassoc - built-in function 'assoc' */
  271. NODE *xassoc(args)
  272.   NODE *args;
  273. {
  274.     NODE *oldstk,x,alist,fcn,*pair,*val;
  275.     int tresult;
  276.  
  277.     /* create a new stack frame */
  278.     oldstk = xlsave(&x,&alist,&fcn,NULL);
  279.  
  280.     /* get the expression to look for and the association list */
  281.     x.n_ptr = xlarg(&args);
  282.     alist.n_ptr = xlmatch(LIST,&args);
  283.     xltest(&fcn.n_ptr,&tresult,&args);
  284.     xllastarg(args);
  285.  
  286.     /* look for the expression */
  287.     for (val = NULL; consp(alist.n_ptr); alist.n_ptr = cdr(alist.n_ptr))
  288.     if ((pair = car(alist.n_ptr)) && consp(pair))
  289.         if (dotest(x.n_ptr,car(pair),fcn.n_ptr) == tresult) {
  290.         val = pair;
  291.         break;
  292.         }
  293.  
  294.     /* restore the previous stack frame */
  295.     xlstack = oldstk;
  296.  
  297.     /* return the result */
  298.     return (val);
  299. }
  300.  
  301. /* xsubst - substitute one expression for another */
  302. NODE *xsubst(args)
  303.   NODE *args;
  304. {
  305.     NODE *oldstk,to,from,expr,fcn,*val;
  306.     int tresult;
  307.  
  308.     /* create a new stack frame */
  309.     oldstk = xlsave(&to,&from,&expr,&fcn,NULL);
  310.  
  311.     /* get the to value, the from value and the expression */
  312.     to.n_ptr = xlarg(&args);
  313.     from.n_ptr = xlarg(&args);
  314.     expr.n_ptr = xlarg(&args);
  315.     xltest(&fcn.n_ptr,&tresult,&args);
  316.     xllastarg(args);
  317.  
  318.     /* do the substitution */
  319.     val = subst(to.n_ptr,from.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
  320.  
  321.     /* restore the previous stack frame */
  322.     xlstack = oldstk;
  323.  
  324.     /* return the result */
  325.     return (val);
  326. }
  327.  
  328. /* subst - substitute one expression for another */
  329. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  330.   NODE *to,*from,*expr,*fcn; int tresult;
  331. {
  332.     NODE *oldstk,carval,cdrval,*val;
  333.  
  334.     if (dotest(expr,from,fcn) == tresult)
  335.     val = to;
  336.     else if (consp(expr)) {
  337.     oldstk = xlsave(&carval,&cdrval,NULL);
  338.     carval.n_ptr = subst(to,from,car(expr),fcn,tresult);
  339.     cdrval.n_ptr = subst(to,from,cdr(expr),fcn,tresult);
  340.     val = newnode(LIST);
  341.     rplaca(val,carval.n_ptr);
  342.     rplacd(val,cdrval.n_ptr);
  343.     xlstack = oldstk;
  344.     }
  345.     else
  346.     val = expr;
  347.     return (val);
  348. }
  349.  
  350. /* xsublis - substitute using an association list */
  351. NODE *xsublis(args)
  352.   NODE *args;
  353. {
  354.     NODE *oldstk,alist,expr,fcn,*val;
  355.     int tresult;
  356.  
  357.     /* create a new stack frame */
  358.     oldstk = xlsave(&alist,&expr,&fcn,NULL);
  359.  
  360.     /* get the assocation list and the expression */
  361.     alist.n_ptr = xlmatch(LIST,&args);
  362.     expr.n_ptr = xlarg(&args);
  363.     xltest(&fcn.n_ptr,&tresult,&args);
  364.     xllastarg(args);
  365.  
  366.     /* do the substitution */
  367.     val = sublis(alist.n_ptr,expr.n_ptr,fcn.n_ptr,tresult);
  368.  
  369.     /* restore the previous stack frame */
  370.     xlstack = oldstk;
  371.  
  372.     /* return the result */
  373.     return (val);
  374. }
  375.  
  376. /* sublis - substitute using an association list */
  377. LOCAL NODE *sublis(alist,expr,fcn,tresult)
  378.   NODE *alist,*expr,*fcn; int tresult;
  379. {
  380.     NODE *oldstk,carval,cdrval,*val;
  381.  
  382.     if (val = assoc(expr,alist,fcn,tresult))
  383.     val = cdr(val);
  384.     else if (consp(expr)) {
  385.     oldstk = xlsave(&carval,&cdrval,NULL);
  386.     carval.n_ptr = sublis(alist,car(expr),fcn,tresult);
  387.     cdrval.n_ptr = sublis(alist,cdr(expr),fcn,tresult);
  388.     val = newnode(LIST);
  389.     rplaca(val,carval.n_ptr);
  390.     rplacd(val,cdrval.n_ptr);
  391.     xlstack = oldstk;
  392.     }
  393.     else
  394.     val = expr;
  395.     return (val);
  396. }
  397.  
  398. /* assoc - find a pair in an association list */
  399. LOCAL NODE *assoc(expr,alist,fcn,tresult)
  400.   NODE *expr,*alist,*fcn; int tresult;
  401. {
  402.     NODE *pair;
  403.  
  404.     for (; consp(alist); alist = cdr(alist))
  405.     if ((pair = car(alist)) && consp(pair))
  406.         if (dotest(expr,car(pair),fcn) == tresult)
  407.         return (pair);
  408.     return (NULL);
  409. }
  410.  
  411. /* xremove - built-in function 'remove' */
  412. NODE *xremove(args)
  413.   NODE *args;
  414. {
  415.     NODE *oldstk,x,list,fcn,val,*p,*last;
  416.     int tresult;
  417.  
  418.     /* create a new stack frame */
  419.     oldstk = xlsave(&x,&list,&fcn,&val,NULL);
  420.  
  421.     /* get the expression to remove and the list */
  422.     x.n_ptr = xlarg(&args);
  423.     list.n_ptr = xlmatch(LIST,&args);
  424.     xltest(&fcn.n_ptr,&tresult,&args);
  425.     xllastarg(args);
  426.  
  427.     /* remove matches */
  428.     while (consp(list.n_ptr)) {
  429.  
  430.     /* check to see if this element should be deleted */
  431.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult) {
  432.         p = newnode(LIST);
  433.         rplaca(p,car(list.n_ptr));
  434.         if (val.n_ptr) rplacd(last,p);
  435.         else val.n_ptr = p;
  436.         last = p;
  437.     }
  438.  
  439.     /* move to the next element */
  440.     list.n_ptr = cdr(list.n_ptr);
  441.     }
  442.  
  443.     /* restore the previous stack frame */
  444.     xlstack = oldstk;
  445.  
  446.     /* return the updated list */
  447.     return (val.n_ptr);
  448. }
  449.  
  450. /* dotest - call a test function */
  451. int dotest(arg1,arg2,fcn)
  452.   NODE *arg1,*arg2,*fcn;
  453. {
  454.     NODE *oldstk,args,*val;
  455.  
  456.     /* create a new stack frame */
  457.     oldstk = xlsave(&args,NULL);
  458.  
  459.     /* build an argument list */
  460.     args.n_ptr = newnode(LIST);
  461.     rplaca(args.n_ptr,arg1);
  462.     rplacd(args.n_ptr,newnode(LIST));
  463.     rplaca(cdr(args.n_ptr),arg2);
  464.  
  465.     /* apply the test function */
  466.     val = xlapply(fcn,args.n_ptr);
  467.  
  468.     /* restore the previous stack frame */
  469.     xlstack = oldstk;
  470.  
  471.     /* return the result of the test */
  472.     return (val != NULL);
  473. }
  474.  
  475. /* xnth - return the nth element of a list */
  476. NODE *xnth(args)
  477.   NODE *args;
  478. {
  479.     return (nth(args,FALSE));
  480. }
  481.  
  482. /* xnthcdr - return the nth cdr of a list */
  483. NODE *xnthcdr(args)
  484.   NODE *args;
  485. {
  486.     return (nth(args,TRUE));
  487. }
  488.  
  489. /* nth - internal nth function */
  490. LOCAL NODE *nth(args,cdrflag)
  491.   NODE *args; int cdrflag;
  492. {
  493.     NODE *list;
  494.     int n;
  495.  
  496.     /* get n and the list */
  497.     if ((n = xlmatch(INT,&args)->n_int) < 0)
  498.     xlfail("bad argument");
  499.     if ((list = xlmatch(LIST,&args)) == NULL)
  500.     xlfail("bad argument");
  501.     xllastarg(args);
  502.  
  503.     /* find the nth element */
  504.     for (; n > 0; n--) {
  505.     list = cdr(list);
  506.     if (!consp(list))
  507.         xlfail("bad argument");
  508.     }
  509.  
  510.     /* return the list beginning at the nth element */
  511.     return (cdrflag ? list : car(list));
  512. }
  513.  
  514. /* xlength - return the length of a list */
  515. NODE *xlength(args)
  516.   NODE *args;
  517. {
  518.     NODE *list,*val;
  519.     int n;
  520.  
  521.     /* get the list */
  522.     list = xlmatch(LIST,&args);
  523.     xllastarg(args);
  524.  
  525.     /* find the length */
  526.     for (n = 0; consp(list); n++)
  527.     list = cdr(list);
  528.  
  529.     /* create the value node */
  530.     val = newnode(INT);
  531.     val->n_int = n;
  532.  
  533.     /* return the length */
  534.     return (val);
  535. }
  536.  
  537. /* xmapc - built-in function 'mapc' */
  538. NODE *xmapc(args)
  539.   NODE *args;
  540. {
  541.     return (map(args,TRUE,FALSE));
  542. }
  543.  
  544. /* xmapcar - built-in function 'mapcar' */
  545. NODE *xmapcar(args)
  546.   NODE *args;
  547. {
  548.     return (map(args,TRUE,TRUE));
  549. }
  550.  
  551. /* xmapl - built-in function 'mapl' */
  552. NODE *xmapl(args)
  553.   NODE *args;
  554. {
  555.     return (map(args,FALSE,FALSE));
  556. }
  557.  
  558. /* xmaplist - built-in function 'maplist' */
  559. NODE *xmaplist(args)
  560.   NODE *args;
  561. {
  562.     return (map(args,FALSE,TRUE));
  563. }
  564.  
  565. /* map - internal mapping function */
  566. LOCAL NODE *map(args,carflag,valflag)
  567.   NODE *args; int carflag,valflag;
  568. {
  569.     NODE *oldstk,fcn,lists,arglist,val,*last,*p,*x,*y;
  570.  
  571.     /* create a new stack frame */
  572.     oldstk = xlsave(&fcn,&lists,&arglist,&val,NULL);
  573.  
  574.     /* get the function to apply and the first list */
  575.     fcn.n_ptr = xlarg(&args);
  576.     lists.n_ptr = xlmatch(LIST,&args);
  577.  
  578.     /* save the first list if not saving function values */
  579.     if (!valflag)
  580.     val.n_ptr = lists.n_ptr;
  581.  
  582.     /* set up the list of argument lists */
  583.     p = newnode(LIST);
  584.     rplaca(p,lists.n_ptr);
  585.     lists.n_ptr = p;
  586.  
  587.     /* get the remaining argument lists */
  588.     while (args) {
  589.     p = newnode(LIST);
  590.     rplacd(p,lists.n_ptr);
  591.     lists.n_ptr = p;
  592.     rplaca(p,xlmatch(LIST,&args));
  593.     }
  594.  
  595.     /* if the function is a symbol, get its value */
  596.     if (symbolp(fcn.n_ptr))
  597.     fcn.n_ptr = xleval(fcn.n_ptr);
  598.  
  599.     /* loop through each of the argument lists */
  600.     for (;;) {
  601.  
  602.     /* build an argument list from the sublists */
  603.     arglist.n_ptr = NULL;
  604.     for (x = lists.n_ptr; x && (y = car(x)) && consp(y); x = cdr(x)) {
  605.         p = newnode(LIST);
  606.         rplacd(p,arglist.n_ptr);
  607.         arglist.n_ptr = p;
  608.         rplaca(p,carflag ? car(y) : y);
  609.         rplaca(x,cdr(y));
  610.     }
  611.  
  612.     /* quit if any of the lists were empty */
  613.     if (x) break;
  614.  
  615.     /* apply the function to the arguments */
  616.     if (valflag) {
  617.         p = newnode(LIST);
  618.         if (val.n_ptr) rplacd(last,p);
  619.         else val.n_ptr = p;
  620.         rplaca(p,xlapply(fcn.n_ptr,arglist.n_ptr));
  621.         last = p;
  622.     }
  623.     else
  624.         xlapply(fcn.n_ptr,arglist.n_ptr);
  625.     }
  626.  
  627.     /* restore the previous stack frame */
  628.     xlstack = oldstk;
  629.  
  630.     /* return the last test expression value */
  631.     return (val.n_ptr);
  632. }
  633.  
  634. /* xrplca - replace the car of a list node */
  635. NODE *xrplca(args)
  636.   NODE *args;
  637. {
  638.     NODE *list,*newcar;
  639.  
  640.     /* get the list and the new car */
  641.     if ((list = xlmatch(LIST,&args)) == NULL)
  642.     xlfail("bad argument");
  643.     newcar = xlarg(&args);
  644.     xllastarg(args);
  645.  
  646.     /* replace the car */
  647.     rplaca(list,newcar);
  648.  
  649.     /* return the list node that was modified */
  650.     return (list);
  651. }
  652.  
  653. /* xrplcd - replace the cdr of a list node */
  654. NODE *xrplcd(args)
  655.   NODE *args;
  656. {
  657.     NODE *list,*newcdr;
  658.  
  659.     /* get the list and the new cdr */
  660.     if ((list = xlmatch(LIST,&args)) == NULL)
  661.     xlfail("bad argument");
  662.     newcdr = xlarg(&args);
  663.     xllastarg(args);
  664.  
  665.     /* replace the cdr */
  666.     rplacd(list,newcdr);
  667.  
  668.     /* return the list node that was modified */
  669.     return (list);
  670. }
  671.  
  672. /* xnconc - destructively append lists */
  673. NODE *xnconc(args)
  674.   NODE *args;
  675. {
  676.     NODE *list,*last,*val;
  677.  
  678.     /* concatenate each argument */
  679.     for (val = NULL; args; ) {
  680.  
  681.     /* concatenate this list */
  682.     if (list = xlmatch(LIST,&args)) {
  683.  
  684.         /* check for this being the first non-empty list */
  685.         if (val)
  686.         rplacd(last,list);
  687.         else
  688.         val = list;
  689.  
  690.         /* find the end of the list */
  691.         while (consp(list) && cdr(list))
  692.         list = cdr(list);
  693.  
  694.         /* make sure the list ended correctly */
  695.         if (!consp(list))
  696.         xlfail("bad list");
  697.  
  698.         /* save the new last element */
  699.         last = list;
  700.     }
  701.     }
  702.  
  703.     /* return the list */
  704.     return (val);
  705. }
  706.  
  707. /* xdelete - built-in function 'delete' */
  708. NODE *xdelete(args)
  709.   NODE *args;
  710. {
  711.     NODE *oldstk,x,list,fcn,*last,*val;
  712.     int tresult;
  713.  
  714.     /* create a new stack frame */
  715.     oldstk = xlsave(&x,&list,&fcn,NULL);
  716.  
  717.     /* get the expression to delete and the list */
  718.     x.n_ptr = xlarg(&args);
  719.     list.n_ptr = xlmatch(LIST,&args);
  720.     xltest(&fcn.n_ptr,&tresult,&args);
  721.     xllastarg(args);
  722.  
  723.     /* delete leading matches */
  724.     while (consp(list.n_ptr)) {
  725.     if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) != tresult)
  726.         break;
  727.     list.n_ptr = cdr(list.n_ptr);
  728.     }
  729.     val = last = list.n_ptr;
  730.  
  731.     /* delete embedded matches */
  732.     if (consp(list.n_ptr)) {
  733.  
  734.     /* skip the first non-matching element */
  735.     list.n_ptr = cdr(list.n_ptr);
  736.  
  737.     /* look for embedded matches */
  738.     while (consp(list.n_ptr)) {
  739.  
  740.         /* check to see if this element should be deleted */
  741.         if (dotest(x.n_ptr,car(list.n_ptr),fcn.n_ptr) == tresult)
  742.         rplacd(last,cdr(list.n_ptr));
  743.         else
  744.         last = list.n_ptr;
  745.  
  746.         /* move to the next element */
  747.         list.n_ptr = cdr(list.n_ptr);
  748.      }
  749.     }
  750.  
  751.     /* make sure the list ended in a nil */
  752.     if (list.n_ptr != NULL)
  753.     xlfail("bad list");
  754.  
  755.     /* restore the previous stack frame */
  756.     xlstack = oldstk;
  757.  
  758.     /* return the updated list */
  759.     return (val);
  760. }
  761.  
  762. /* xatom - is this an atom? */
  763. NODE *xatom(args)
  764.   NODE *args;
  765. {
  766.     NODE *arg;
  767.     arg = xlarg(&args);
  768.     xllastarg(args);
  769.     return (atom(arg) ? true : NULL);
  770. }
  771.  
  772. /* xsymbolp - is this an symbol? */
  773. NODE *xsymbolp(args)
  774.   NODE *args;
  775. {
  776.     NODE *arg;
  777.     arg = xlarg(&args);
  778.     xllastarg(args);
  779.     return (arg == NULL || symbolp(arg) ? true : NULL);
  780. }
  781.  
  782. /* xnumberp - is this an number? */
  783. NODE *xnumberp(args)
  784.   NODE *args;
  785. {
  786.     NODE *arg;
  787.     arg = xlarg(&args);
  788.     xllastarg(args);
  789.     return (fixp(arg) ? true : NULL);
  790. }
  791.  
  792. /* xboundp - is this a value bound to this symbol? */
  793. NODE *xboundp(args)
  794.   NODE *args;
  795. {
  796.     NODE *sym;
  797.     sym = xlmatch(SYM,&args);
  798.     xllastarg(args);
  799.     return (sym->n_symvalue == s_unbound ? NULL : true);
  800. }
  801.  
  802. /* xnull - is this null? */
  803. NODE *xnull(args)
  804.   NODE *args;
  805. {
  806.     NODE *arg;
  807.     arg = xlarg(&args);
  808.     xllastarg(args);
  809.     return (null(arg) ? true : NULL);
  810. }
  811.  
  812. /* xlistp - is this a list? */
  813. NODE *xlistp(args)
  814.   NODE *args;
  815. {
  816.     NODE *arg;
  817.     arg = xlarg(&args);
  818.     xllastarg(args);
  819.     return (listp(arg) ? true : NULL);
  820. }
  821.  
  822. /* xconsp - is this a cons? */
  823. NODE *xconsp(args)
  824.   NODE *args;
  825. {
  826.     NODE *arg;
  827.     arg = xlarg(&args);
  828.     xllastarg(args);
  829.     return (consp(arg) ? true : NULL);
  830. }
  831.  
  832. /* xeq - are these equal? */
  833. NODE *xeq(args)
  834.   NODE *args;
  835. {
  836.     return (cequal(args,eq));
  837. }
  838.  
  839. /* xeql - are these equal? */
  840. NODE *xeql(args)
  841.   NODE *args;
  842. {
  843.     return (cequal(args,eql));
  844. }
  845.  
  846. /* xequal - are these equal? */
  847. NODE *xequal(args)
  848.   NODE *args;
  849. {
  850.     return (cequal(args,equal));
  851. }
  852.  
  853. /* cequal - common eq/eql/equal function */
  854. LOCAL NODE *cequal(args,fcn)
  855.   NODE *args; int (*fcn)();
  856. {
  857.     NODE *arg1,*arg2;
  858.  
  859.     /* get the two arguments */
  860.     arg1 = xlarg(&args);
  861.     arg2 = xlarg(&args);
  862.     xllastarg(args);
  863.  
  864.     /* compare the arguments */
  865.     return ((*fcn)(arg1,arg2) ? true : NULL);
  866. }
  867.